Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/code_gen/vbxwzrd/backgrnd.pas

Pascal/Delphi Source File | 1995-02-20 | 5.4 KB | 168 lines

{
  Program: BackGrnd
  Date: 20/2/1995
  Purpose: To create a custom control (vbx) for Visual Basic or Delphi
}
Library BackGrnd;
{$R BackGrnd}
Uses WinTypes,WinProcs,VBApi;
{ Custom control data and structs }
Type PBackGrnd=^TBackGrnd;
     TBackGrnd=Record
      About:Enum;
      Picture:hPic;
     End;
Const
{ Declare Property }
      Property_About:TPROPINFO=(
      npszName:NPnt(PChar('(About)'));
      fl:DT_ENUM or PF_fGetData or PF_fSetData or PF_fSetMsg;
      offsetData:Byte(0);
      infoData:0;
      dataDefault:0;
      npszEnumList:Npnt(PChar('Click on "..." for About Box'+#0+#0));
      enumMax:0);
      Property_Picture:TPROPINFO=(
      npszName:NPnt(PChar('Picture'));
      fl:DT_PICTURE or PF_fGetData or PF_fSaveData or PF_fSetData or PF_fSetMsg;
      offsetData:Byte(1);
      infoData:0;
      dataDefault:0;
      npszEnumList:Npnt(PChar(+#0+#0));
      enumMax:0);
{ Declare Events }
      Event_BeginPaint:TEVENTINFO=(
      npszName:NPnt(PChar('BeginPaint'));
      cParms:0;
      cwParms:2*0;
      npParmTypes:0;
      npszParmProf:NPnt(PChar(''));
      fl:0);
      Event_EndPaint:TEVENTINFO=(
      npszName:NPnt(PChar('EndPaint'));
      cParms:0;
      cwParms:2*0;
      npParmTypes:0;
      npszParmProf:NPnt(PChar(''));
      fl:0);
{ Property List }
      PropListBackGrnd:array[0..11] of PPropInfo=(
      PPropInfo_Std_CTLNAME,
      PPropInfo_Std_HWND,
      PPropInfo_Std_INDEX,
      PPropInfo(@Property_About),
      PPropInfo_Std_ENABLED,
      PPropInfo_Std_HEIGHT,
      PPropInfo_Std_LEFT,
      PPropInfo_Std_TOP,
      PPropInfo_Std_VISIBLE,
      PPropInfo_Std_WIDTH,
      PPropInfo(@Property_Picture),0);
{ Event List }
      EventListBackGrnd:array[0..7] of PEventInfo=(
      PEventInfo(@Event_BeginPaint),
      PEventInfo_Std_CLICK,
      PEventInfo_Std_DBLCLICK,
      PEventInfo(@Event_EndPaint),
      PEventInfo_Std_MOUSEDOWN,
      PEventInfo_Std_MOUSEMOVE,
      PEventInfo_Std_MOUSEUP,0);
{ This routine handles the 'About' Dialog messages }
function AboutDlgProc(Dlg:HWnd;Msg,wParam:Word;lParam:LongInt):Bool; export;
begin
  AboutDlgProc:=False;
  case Msg of
    WM_Create:AboutDlgProc:=True;
    WM_InitDialog:Exit;
    WM_Command:if (wParam=id_OK)or(wParam=id_Cancel) then EndDialog(Dlg,0);
  end;{End of Case}
end;
{ Constans and Variables }
{ Control Procedure }
{ This routine is called for all VB and Windows Messages }
function BackGrndCtlProc(Control:hCtl;Wnd:hWnd;Msg,wParam:Word;lParam:LongInt):LongInt; Export;
const hBrOld:hBrush=0;
var TP:TPaintStruct;
    Pic:Tpic;
    hPicture:hPic;
    BMP:TBitmap;
    hBR:hBrush;
    MemDC:hDC;
    Rect:TRect;
    X,Y:Integer;
begin
  case Msg of
    WM_PAINT:
    begin
      if VBGetMode=MODE_RUN then VBFireEvent(Control,0,nil);
      BeginPaint(Wnd,TP);
      VBGetControlProperty(Control,10,@hPicture);
      if hPicture<>0 then
        begin
          VBGetPic(hPicture,@Pic);
          hBR:=GetBrushOrg(TP.hDC);
          if Bool(hbr) then hbrOld:=SelectObject(TP.hDC,hBR);
          GetClientRect(Wnd,Rect);
          GetObject(Pic.PicData.Bitmap,sizeof(TBitMap),PChar(@Bmp));
          MemDC:=CreateCompatibleDC(TP.hDC);
          SelectObject(MemDC,Pic.PicData.Bitmap);
          Y:=0;
          while Y<Rect.Bottom do
          begin
            X:=0;
            while X<Rect.Right do
            begin
              BitBlt(TP.hDC,X,Y,BMP.bmWidth,BMP.bmHeight,MemDC,0,0,SRCCOPY);
              X:=X+BMP.bmWidth;
            end;
            Y:=Y+BMP.bmHeight;
          end;
          SelectObject(TP.hDC,hbrOld);
          DeleteDC(MemDC);
        end;
      EndPaint(Wnd,TP);
      if VBGetMode=MODE_RUN then VBFireEvent(Control,3,nil);
      Exit;
    end;
    VBM_SETPROPERTY:if wParam=10 then InvalidateRect(Wnd,nil,True);
    WM_USER:VBDialogBoxParam(hInstance,'ABOUT',@AboutDlgProc,0);WM_USER+1:VBDialogBoxParam(hInstance,'ABOUT',@AboutDlgProc,0);
    VBM_INITPROPPOPUP:if wParam=3 then
    begin
      BackGrndCtlProc:=LoWord(lParam+1);
      PostMessage(Wnd,WM_USER,0,0);
      Exit;
    end;
  end;    { End of case Msg }
  BackGrndCtlProc:=VBDefControlProc(Control,Wnd,Msg,wParam,lParam);
end; {End of Control function}
{ Model struct                               }
{ Define the control model                   }
{ (using the event and property structures). }
Const ModelBackGrnd:TModel=(
      UsVersion:VB300_VERSION;    { VB version used by control }
      Fl:0;
      CtlProc:TFarProc(@BackGrndCtlProc);
      FsClassStyle:0 or cs_HRedraw or cs_VRedraw;
      FlWndStyle:0;
      CbCtlExtra:SizeOf(TBackGrnd);
      IdBmpPalette:8000;          { Bitmap ID for tool palette }
      DefCtlName:NPnt(PChar('BackGrnd'));
      ClassName:NPnt(PChar('BackGrnd'));
      ParentClassName:0;
      PropList:Ofs(PropListBackGrnd);
      EventList:Ofs(EventListBackGrnd);
      NDefProp:0;                 { Index of default property }
      NDefEvent:0);               { Index of default event }
{ Register custom control.                     }
{ This routine is called by VB when the custom }
{ control DLL is loaded for use.               }
function VBInitCC(usVersion:Word;fRunTime:Boolean):Boolean; Export;
begin
  VBInitCC:=VBRegisterModel(hInstance,ModelBackGrnd);
end;
Exports
  VBInitCC         index 2,
  BackGrndCtlProc index 3,
  AboutDlgProc;
Begin
End. { End of Custom Control }